Shareware Grab Bag/Shareware Grab Bag.iso/007/tbbyte.arc/WRDS2.PAS

Pascal/Delphi Source File | 1985-08-14 | 4.1 KB | 191 lines

PROGRAM concordance;


{    Word frequency program

     Author:          Peter Grogono
     Date Written:    September, 1977

     From: Programming in Pascal
           by Peter Grogono

     Modified for Turbo Pascal 2.0b
     by David W. Carroll
     May 5, 1985
     Version 2

}

CONST
 maxwordlen = 20;

TYPE
  charindex = 1 .. maxwordlen;
  counttype = 1 .. maxint;
  wordtype = ARRAY [charindex] OF char;

  pointer = ^entrytype;
  entrytype =
    RECORD
      left, right : pointer;
      word : wordtype;
      count : counttype
    END;

VAR
  wordtree : pointer;
  nextword : wordtype;
  letters : SET OF char;
  infile : TEXT;

  PROCEDURE inblock;
  CONST
    bell = 07;

  VAR
    infname : string [20];
    goodfile : boolean;

  BEGIN
     repeat
        ClrScr;
        write ('Input filename  -->  ');
        readln (infname);
        assign(infile,infname);
        {$I-} reset(infile) {$I+};
        goodfile := (IOresult = 0);
        if not goodfile then
        begin
          write (chr(bell));
          writeln ('FILE ',infname,' NOT FOUND');
          delay(3000)
        end;
     until goodfile;
  END;

procedure Uppercase(var Str : wordtype);
var
 indx,len    : counttype;

begin
  Len := maxwordlen;
  for Indx := 1 to len do
     Str[Indx] := UpCase(Str[Indx]);
end;


  PROCEDURE readword (VAR wrd : wordtype);
    CONST
      blank = ' ';

    VAR
      buffer : ARRAY [charindex] OF char;
      charcount : 0 .. maxwordlen;
      ch : char;

    BEGIN
      IF NOT eof(infile) THEN
        REPEAT
          read(infile,ch);
          ch := chr(ord(ch) AND 127);
        UNTIL eof(infile) OR (ch IN letters);
      IF NOT eof(infile) THEN
        BEGIN
          charcount := 0;
          WHILE ch IN letters DO
            BEGIN
              IF charcount < maxwordlen THEN
                BEGIN
                  charcount := charcount + 1;
                  buffer[charcount] := ch
                END;
              IF eof(infile) THEN
                ch := blank
              ELSE
                BEGIN
                  read(infile,ch);
                  ch := chr(ord(ch) AND 127)
                END;
            END; {while}
          FOR charcount := charcount + 1 TO maxwordlen DO
            buffer[charcount] := blank;
          wrd := buffer
        END
    END; {readword}


  PROCEDURE printword (wrd : wordtype);
    CONST
      blank = ' ';

    VAR
      buffer : ARRAY [charindex] OF char;
      charpos : 1 .. maxwordlen;

    BEGIN
      buffer := wrd;
      FOR charpos := 1 TO maxwordlen DO
        write(buffer[charpos])
    END; {printword}




PROCEDURE makeentry (VAR tree : pointer; entry : wordtype);
VAR
  uentry : wordtype;
  uword : wordtype;

    BEGIN
      IF tree = NIL THEN
        BEGIN
          new(tree);
          WITH tree^ DO
            BEGIN
              word := entry;
              count := 1;
              left := NIL;
              right := NIL
            END; {with}
        END
      ELSE
        WITH tree^ DO
          BEGIN
            uentry := entry;
            uppercase(uentry);
            uword := word;
            uppercase(uword);
            IF uentry < uword THEN
              makeentry(left,entry)
            ELSE IF uentry > uword THEN
              makeentry(right,entry)
            ELSE count := count + 1
          END
    END; {makeentry}

  PROCEDURE printtree (tree : pointer);
    BEGIN
      IF tree <> NIL THEN
        WITH tree^ DO
          BEGIN
            printtree(left);
            printword(word);
            writeln(count);
            printtree(right)
          END
    END; {printtree}

  BEGIN {concordance}
    letters := ['a' .. 'z','A' .. 'Z'];
    wordtree := NIL;
    inblock;
    WHILE NOT eof(infile) DO
      BEGIN
        readword(nextword);
        IF NOT eof(infile) THEN
          makeentry(wordtree,nextword)
      END; {while}
    printtree(wordtree)
  END.  {concordance}